home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / nnmh.el.z / nnmh.el
Encoding:
Text File  |  1998-05-21  |  17.8 KB  |  566 lines
  1. ;;; nnmh.el --- mhspool access for Gnus
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; Based on nnspool.el by Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>.
  28. ;; For an overview of what the interface functions do, please see the
  29. ;; Gnus sources.
  30.  
  31. ;;; Code:
  32.  
  33. (require 'nnheader)
  34. (require 'nnmail)
  35. (require 'gnus-start)
  36. (require 'nnoo)
  37. (eval-when-compile (require 'cl))
  38.  
  39. (nnoo-declare nnmh)
  40.  
  41. (defvoo nnmh-directory message-directory
  42.   "*Mail spool directory.")
  43.  
  44. (defvoo nnmh-get-new-mail t
  45.   "*If non-nil, nnmh will check the incoming mail file and split the mail.")
  46.  
  47. (defvoo nnmh-prepare-save-mail-hook nil
  48.   "*Hook run narrowed to an article before saving.")
  49.  
  50. (defvoo nnmh-be-safe nil
  51.   "*If non-nil, nnmh will check all articles to make sure whether they are new or not.")
  52.  
  53.  
  54.  
  55. (defconst nnmh-version "nnmh 1.0"
  56.   "nnmh version.")
  57.  
  58. (defvoo nnmh-current-directory nil
  59.   "Current news group directory.")
  60.  
  61. (defvoo nnmh-status-string "")
  62. (defvoo nnmh-group-alist nil)
  63.  
  64.  
  65.  
  66. ;;; Interface functions.
  67.  
  68. (nnoo-define-basics nnmh)
  69.  
  70. (deffoo nnmh-retrieve-headers (articles &optional newsgroup server fetch-old)
  71.   (save-excursion
  72.     (set-buffer nntp-server-buffer)
  73.     (erase-buffer)
  74.     (let* ((file nil)
  75.        (number (length articles))
  76.        (large (and (numberp nnmail-large-newsgroup)
  77.                (> number nnmail-large-newsgroup)))
  78.        (count 0)
  79.        ;; 1997/8/12 by MORIOKA Tomohiko
  80.        ;;    for XEmacs/mule.
  81.        (pathname-coding-system 'binary)
  82.        beg article)
  83.       (nnmh-possibly-change-directory newsgroup server)
  84.       ;; We don't support fetching by Message-ID.
  85.       (if (stringp (car articles))
  86.       'headers
  87.     (while articles
  88.       (when (and (file-exists-p
  89.               (setq file (concat (file-name-as-directory
  90.                       nnmh-current-directory)
  91.                      (int-to-string
  92.                       (setq article (pop articles))))))
  93.              (not (file-directory-p file)))
  94.         (insert (format "221 %d Article retrieved.\n" article))
  95.         (setq beg (point))
  96.         (nnheader-insert-head file)
  97.         (goto-char beg)
  98.         (if (search-forward "\n\n" nil t)
  99.         (forward-char -1)
  100.           (goto-char (point-max))
  101.           (insert "\n\n"))
  102.         (insert ".\n")
  103.         (delete-region (point) (point-max)))
  104.       (setq count (1+ count))
  105.  
  106.       (and large
  107.            (zerop (% count 20))
  108.            (message "nnmh: Receiving headers... %d%%"
  109.             (/ (* count 100) number))))
  110.  
  111.     (when large
  112.       (message "nnmh: Receiving headers...done"))
  113.  
  114.     (nnheader-fold-continuation-lines)
  115.     'headers))))
  116.  
  117. (deffoo nnmh-open-server (server &optional defs)
  118.   (nnoo-change-server 'nnmh server defs)
  119.   (when (not (file-exists-p nnmh-directory))
  120.     (condition-case ()
  121.     (make-directory nnmh-directory t)
  122.       (error t)))
  123.   (cond
  124.    ((not (file-exists-p nnmh-directory))
  125.     (nnmh-close-server)
  126.     (nnheader-report 'nnmh "Couldn't create directory: %s" nnmh-directory))
  127.    ((not (file-directory-p (file-truename nnmh-directory)))
  128.     (nnmh-close-server)
  129.     (nnheader-report 'nnmh "Not a directory: %s" nnmh-directory))
  130.    (t
  131.     (nnheader-report 'nnmh "Opened server %s using directory %s"
  132.              server nnmh-directory)
  133.     t)))
  134.  
  135. (deffoo nnmh-request-article (id &optional newsgroup server buffer)
  136.   (nnmh-possibly-change-directory newsgroup server)
  137.   (let ((file (if (stringp id)
  138.           nil
  139.         (concat nnmh-current-directory (int-to-string id))))
  140.     ;; 1997/8/12 by MORIOKA Tomohiko
  141.     ;;    for XEmacs/mule.
  142.     (pathname-coding-system 'binary)
  143.     (nntp-server-buffer (or buffer nntp-server-buffer)))
  144.     (and (stringp file)
  145.      (file-exists-p file)
  146.      (not (file-directory-p file))
  147.      (save-excursion (nnmail-find-file file))
  148.      (string-to-int (file-name-nondirectory file)))))
  149.  
  150. (deffoo nnmh-request-group (group &optional server dont-check)
  151.   (let ((pathname (nnmail-group-pathname group nnmh-directory))
  152.     ;; 1997/8/12 by MORIOKA Tomohiko
  153.     ;;    for XEmacs/mule.
  154.     (pathname-coding-system 'binary)
  155.     dir)
  156.     (cond
  157.      ((not (file-directory-p pathname))
  158.       (nnheader-report
  159.        'nnmh "Can't select group (no such directory): %s" group))
  160.      (t
  161.       (setq nnmh-current-directory pathname)
  162.       (and nnmh-get-new-mail
  163.        nnmh-be-safe
  164.        (nnmh-update-gnus-unreads group))
  165.       (cond
  166.        (dont-check
  167.     (nnheader-report 'nnmh "Selected group %s" group)
  168.     t)
  169.        (t
  170.     ;; Re-scan the directory if it's on a foreign system.
  171.     (nnheader-re-read-dir pathname)
  172.     (setq dir
  173.           (sort
  174.            (mapcar (lambda (name) (string-to-int name))
  175.                (directory-files pathname nil "^[0-9]+$" t))
  176.            '<))
  177.       (cond
  178.        (dir
  179.         (nnheader-report 'nnmh "Selected group %s" group)
  180.         (nnheader-insert
  181.          "211 %d %d %d %s\n" (length dir) (car dir)
  182.          (progn (while (cdr dir) (setq dir (cdr dir))) (car dir))
  183.          group))
  184.        (t
  185.         (nnheader-report 'nnmh "Empty group %s" group)
  186.         (nnheader-insert (format "211 0 1 0 %s\n" group))))))))))
  187.  
  188. (deffoo nnmh-request-scan (&optional group server)
  189.   (nnmail-get-new-mail 'nnmh nil nnmh-directory group))
  190.  
  191. (deffoo nnmh-request-list (&optional server dir)
  192.   (nnheader-insert "")
  193.   (let ((pathname-coding-system 'binary)
  194.     (nnmh-toplev
  195.      (file-truename (or dir (file-name-as-directory nnmh-directory)))))
  196.     (nnmh-request-list-1 nnmh-toplev))
  197.   (setq nnmh-group-alist (nnmail-get-active))
  198.   t)
  199.  
  200. (defvar nnmh-toplev)
  201. (defun nnmh-request-list-1 (dir)
  202.   (setq dir (expand-file-name dir))
  203.   ;; Recurse down all directories.
  204.   (let ((dirs (and (file-readable-p dir)
  205.            (> (nth 1 (file-attributes (file-chase-links dir))) 2)
  206.            (directory-files dir t nil t)))
  207.     dir)
  208.     ;; Recurse down directories.
  209.     (while (setq dir (pop dirs))
  210.       (when (and (not (member (file-name-nondirectory dir) '("." "..")))
  211.          (file-directory-p dir)
  212.          (file-readable-p dir))
  213.     (nnmh-request-list-1 dir))))
  214.   ;; For each directory, generate an active file line.
  215.   (unless (string= (expand-file-name nnmh-toplev) dir)
  216.     (let ((files (mapcar
  217.           (lambda (name) (string-to-int name))
  218.           (directory-files dir nil "^[0-9]+$" t))))
  219.       (when files
  220.     (save-excursion
  221.       (set-buffer nntp-server-buffer)
  222.       (goto-char (point-max))
  223.       (insert
  224.        (format
  225.         "%s %d %d y\n"
  226.         (progn
  227.           (string-match
  228.            (regexp-quote
  229.         (file-truename (file-name-as-directory
  230.                 (expand-file-name nnmh-toplev))))
  231.            dir)
  232.           (nnheader-replace-chars-in-string
  233.            (decode-coding-string (substring dir (match-end 0))
  234.                      nnmail-pathname-coding-system)
  235.            ?/ ?.))
  236.         (apply 'max files)
  237.         (apply 'min files)))))))
  238.   t)
  239.  
  240. (deffoo nnmh-request-newgroups (date &optional server)
  241.   (nnmh-request-list server))
  242.  
  243. (deffoo nnmh-request-expire-articles (articles newsgroup
  244.                            &optional server force)
  245.   (nnmh-possibly-change-directory newsgroup server)
  246.   (let* ((active-articles
  247.       (mapcar
  248.        (function
  249.         (lambda (name)
  250.           (string-to-int name)))
  251.        (directory-files nnmh-current-directory nil "^[0-9]+$" t)))
  252.      (is-old t)
  253.      article rest mod-time)
  254.     (nnmail-activate 'nnmh)
  255.  
  256.     (while (and articles is-old)
  257.       (setq article (concat nnmh-current-directory
  258.                 (int-to-string (car articles))))
  259.       (when (setq mod-time (nth 5 (file-attributes article)))
  260.     (if (and (nnmh-deletable-article-p newsgroup (car articles))
  261.          (setq is-old
  262.                (nnmail-expired-article-p newsgroup mod-time force)))
  263.         (progn
  264.           (nnheader-message 5 "Deleting article %s in %s..."
  265.                 article newsgroup)
  266.           (condition-case ()
  267.           (funcall nnmail-delete-file-function article)
  268.         (file-error
  269.          (nnheader-message 1 "Couldn't delete article %s in %s"
  270.                    article newsgroup)
  271.          (push (car articles) rest))))
  272.       (push (car articles) rest)))
  273.       (setq articles (cdr articles)))
  274.     (message "")
  275.     (nconc rest articles)))
  276.  
  277. (deffoo nnmh-close-group (group &optional server)
  278.   t)
  279.  
  280. (deffoo nnmh-request-move-article
  281.   (article group server accept-form &optional last)
  282.   (let ((buf (get-buffer-create " *nnmh move*"))
  283.     result)
  284.     (and
  285.      (nnmh-deletable-article-p group article)
  286.      (nnmh-request-article article group server)
  287.      (save-excursion
  288.        (set-buffer buf)
  289.        (erase-buffer)
  290.        (insert-buffer-substring nntp-server-buffer)
  291.        (setq result (eval accept-form))
  292.        (kill-buffer (current-buffer))
  293.        result)
  294.      (progn
  295.        (nnmh-possibly-change-directory group server)
  296.        (condition-case ()
  297.        (funcall nnmail-delete-file-function
  298.             (concat nnmh-current-directory (int-to-string article)))
  299.      (file-error nil))))
  300.     result))
  301.  
  302. (deffoo nnmh-request-accept-article (group &optional server last noinsert)
  303.   (nnmh-possibly-change-directory group server)
  304.   (nnmail-check-syntax)
  305.   (when nnmail-cache-accepted-message-ids
  306.     (nnmail-cache-insert (nnmail-fetch-field "message-id")))
  307.   (prog1
  308.       (if (stringp group)
  309.       (and
  310.        (nnmail-activate 'nnmh)
  311.        (car (nnmh-save-mail
  312.          (list (cons group (nnmh-active-number group)))
  313.          noinsert)))
  314.     (and
  315.      (nnmail-activate 'nnmh)
  316.      (let ((res (nnmail-article-group 'nnmh-active-number)))
  317.        (if (and (null res)
  318.             (yes-or-no-p "Moved to `junk' group; delete article? "))
  319.            'junk
  320.          (car (nnmh-save-mail res noinsert))))))
  321.     (when (and last nnmail-cache-accepted-message-ids)
  322.       (nnmail-cache-close))))
  323.  
  324. (deffoo nnmh-request-replace-article (article group buffer)
  325.   (nnmh-possibly-change-directory group)
  326.   (save-excursion
  327.     (set-buffer buffer)
  328.     (nnmh-possibly-create-directory group)
  329.     (ignore-errors
  330.       (nnmail-write-region
  331.        (point-min) (point-max)
  332.        (concat nnmh-current-directory (int-to-string article))
  333.        nil (if (nnheader-be-verbose 5) nil 'nomesg))
  334.       t)))
  335.  
  336. (deffoo nnmh-request-create-group (group &optional server args)
  337.   (nnmail-activate 'nnmh)
  338.   (unless (assoc group nnmh-group-alist)
  339.     (let (active)
  340.       (push (list group (setq active (cons 1 0)))
  341.         nnmh-group-alist)
  342.       (nnmh-possibly-create-directory group)
  343.       (nnmh-possibly-change-directory group server)
  344.       (let ((articles (mapcar
  345.                (lambda (file)
  346.              (string-to-int file))
  347.                (directory-files
  348.             nnmh-current-directory nil "^[0-9]+$"))))
  349.     (when articles
  350.       (setcar active (apply 'min articles))
  351.       (setcdr active (apply 'max articles))))))
  352.   t)
  353.  
  354. (deffoo nnmh-request-delete-group (group &optional force server)
  355.   (nnmh-possibly-change-directory group server)
  356.   ;; Delete all articles in GROUP.
  357.   (if (not force)
  358.       ()                ; Don't delete the articles.
  359.     (let ((articles (directory-files nnmh-current-directory t "^[0-9]+$")))
  360.       (while articles
  361.     (when (file-writable-p (car articles))
  362.       (nnheader-message 5 "Deleting article %s in %s..."
  363.                 (car articles) group)
  364.       (funcall nnmail-delete-file-function (car articles)))
  365.     (setq articles (cdr articles))))
  366.     ;; Try to delete the directory itself.
  367.     (ignore-errors
  368.       (delete-directory nnmh-current-directory)))
  369.   ;; Remove the group from all structures.
  370.   (setq nnmh-group-alist
  371.     (delq (assoc group nnmh-group-alist) nnmh-group-alist)
  372.     nnmh-current-directory nil)
  373.   t)
  374.  
  375. (deffoo nnmh-request-rename-group (group new-name &optional server)
  376.   (nnmh-possibly-change-directory group server)
  377.   (let ((new-dir (nnmail-group-pathname new-name nnmh-directory))
  378.     (old-dir (nnmail-group-pathname group nnmh-directory)))
  379.     (when (ignore-errors
  380.         (make-directory new-dir t)
  381.         t)
  382.       ;; We move the articles file by file instead of renaming
  383.       ;; the directory -- there may be subgroups in this group.
  384.       ;; One might be more clever, I guess.
  385.       (let ((files (nnheader-article-to-file-alist old-dir)))
  386.     (while files
  387.       (rename-file
  388.        (concat old-dir (cdar files))
  389.        (concat new-dir (cdar files)))
  390.       (pop files)))
  391.       (when (<= (length (directory-files old-dir)) 2)
  392.     (ignore-errors
  393.       (delete-directory old-dir)))
  394.       ;; That went ok, so we change the internal structures.
  395.       (let ((entry (assoc group nnmh-group-alist)))
  396.     (when entry
  397.       (setcar entry new-name))
  398.     (setq nnmh-current-directory nil)
  399.     t))))
  400.  
  401. (nnoo-define-skeleton nnmh)
  402.  
  403.  
  404. ;;; Internal functions.
  405.  
  406. (defun nnmh-possibly-change-directory (newsgroup &optional server)
  407.   (when (and server
  408.          (not (nnmh-server-opened server)))
  409.     (nnmh-open-server server))
  410.   (when newsgroup
  411.     (let ((pathname (nnmail-group-pathname newsgroup nnmh-directory))
  412.       ;; 1997/8/12 by MORIOKA Tomohiko
  413.       ;;    for XEmacs/mule.
  414.       (pathname-coding-system 'binary))
  415.       (if (file-directory-p pathname)
  416.       (setq nnmh-current-directory pathname)
  417.     (error "No such newsgroup: %s" newsgroup)))))
  418.  
  419. (defun nnmh-possibly-create-directory (group)
  420.   (let (dir dirs)
  421.     (setq dir (nnmail-group-pathname group nnmh-directory))
  422.     (while (not (file-directory-p dir))
  423.       (push dir dirs)
  424.       (setq dir (file-name-directory (directory-file-name dir))))
  425.     (while dirs
  426.       (when (make-directory (directory-file-name (car dirs)))
  427.     (error "Could not create directory %s" (car dirs)))
  428.       (nnheader-message 5 "Creating mail directory %s" (car dirs))
  429.       (setq dirs (cdr dirs)))))
  430.  
  431. (defun nnmh-save-mail (group-art &optional noinsert)
  432.   "Called narrowed to an article."
  433.   (unless noinsert
  434.     (nnmail-insert-lines)
  435.     (nnmail-insert-xref group-art))
  436.   (run-hooks 'nnmail-prepare-save-mail-hook)
  437.   (run-hooks 'nnmh-prepare-save-mail-hook)
  438.   (goto-char (point-min))
  439.   (while (looking-at "From ")
  440.     (replace-match "X-From-Line: ")
  441.     (forward-line 1))
  442.   ;; We save the article in all the newsgroups it belongs in.
  443.   (let ((ga group-art)
  444.     first)
  445.     (while ga
  446.       (nnmh-possibly-create-directory (caar ga))
  447.       (let ((file (concat (nnmail-group-pathname
  448.                (caar ga) nnmh-directory)
  449.               (int-to-string (cdar ga)))))
  450.     (if first
  451.         ;; It was already saved, so we just make a hard link.
  452.         (funcall nnmail-crosspost-link-function first file t)
  453.       ;; Save the article.
  454.       (nnmail-write-region (point-min) (point-max) file nil nil)
  455.       (setq first file)))
  456.       (setq ga (cdr ga))))
  457.   group-art)
  458.  
  459. (defun nnmh-active-number (group)
  460.   "Compute the next article number in GROUP."
  461.   (let ((active (cadr (assoc group nnmh-group-alist)))
  462.     (dir (nnmail-group-pathname group nnmh-directory))
  463.     ;; 1997/8/14 by MORIOKA Tomohiko
  464.     ;;    for XEmacs/mule.
  465.     (pathname-coding-system 'binary))
  466.     (unless active
  467.       ;; The group wasn't known to nnmh, so we just create an active
  468.       ;; entry for it.
  469.       (setq active (cons 1 0))
  470.       (push (list group active) nnmh-group-alist)
  471.       (unless (file-exists-p dir)
  472.     (make-directory dir))
  473.       ;; Find the highest number in the group.
  474.       (let ((files (sort
  475.             (mapcar
  476.              (lambda (f)
  477.                (string-to-int f))
  478.              (directory-files dir nil "^[0-9]+$"))
  479.             '>)))
  480.     (when files
  481.       (setcdr active (car files)))))
  482.     (setcdr active (1+ (cdr active)))
  483.     (while (file-exists-p
  484.         (concat (nnmail-group-pathname group nnmh-directory)
  485.             (int-to-string (cdr active))))
  486.       (setcdr active (1+ (cdr active))))
  487.     (cdr active)))
  488.  
  489. (defun nnmh-update-gnus-unreads (group)
  490.   ;; Go through the .nnmh-articles file and compare with the actual
  491.   ;; articles in this folder.  The articles that are "new" will be
  492.   ;; marked as unread by Gnus.
  493.   (let* ((dir nnmh-current-directory)
  494.      (files (sort (mapcar (function (lambda (name) (string-to-int name)))
  495.                   (directory-files nnmh-current-directory
  496.                            nil "^[0-9]+$" t))
  497.               '<))
  498.      (nnmh-file (concat dir ".nnmh-articles"))
  499.      new articles)
  500.     ;; Load the .nnmh-articles file.
  501.     (when (file-exists-p nnmh-file)
  502.       (setq articles
  503.         (let (nnmh-newsgroup-articles)
  504.           (ignore-errors (load nnmh-file nil t t))
  505.           nnmh-newsgroup-articles)))
  506.     ;; Add all new articles to the `new' list.
  507.     (let ((art files))
  508.       (while art
  509.     (unless (assq (car art) articles)
  510.       (push (car art) new))
  511.     (setq art (cdr art))))
  512.     ;; Remove all deleted articles.
  513.     (let ((art articles))
  514.       (while art
  515.     (unless (memq (caar art) files)
  516.       (setq articles (delq (car art) articles)))
  517.     (setq art (cdr art))))
  518.     ;; Check whether the articles really are the ones that Gnus thinks
  519.     ;; they are by looking at the time-stamps.
  520.     (let ((arts articles)
  521.       art)
  522.       (while (setq art (pop arts))
  523.     (when (not (equal
  524.             (nth 5 (file-attributes
  525.                 (concat dir (int-to-string (car art)))))
  526.             (cdr art)))
  527.       (setq articles (delq art articles))
  528.       (push (car art) new))))
  529.     ;; Go through all the new articles and add them, and their
  530.     ;; time-stamps, to the list.
  531.     (setq articles
  532.       (nconc articles
  533.          (mapcar
  534.           (lambda (art)
  535.             (cons art
  536.               (nth 5 (file-attributes
  537.                   (concat dir (int-to-string art))))))
  538.           new)))
  539.     ;; Make Gnus mark all new articles as unread.
  540.     (when new
  541.       (gnus-make-articles-unread
  542.        (gnus-group-prefixed-name group (list 'nnmh ""))
  543.        (setq new (sort new '<))))
  544.     ;; Sort the article list with highest numbers first.
  545.     (setq articles (sort articles (lambda (art1 art2)
  546.                     (> (car art1) (car art2)))))
  547.     ;; Finally write this list back to the .nnmh-articles file.
  548.     (nnheader-temp-write nnmh-file
  549.       (insert ";; Gnus article active file for " group "\n\n")
  550.       (insert "(setq nnmh-newsgroup-articles '")
  551.       (gnus-prin1 articles)
  552.       (insert ")\n"))))
  553.  
  554. (defun nnmh-deletable-article-p (group article)
  555.   "Say whether ARTICLE in GROUP can be deleted."
  556.   (let ((path (concat nnmh-current-directory (int-to-string article))))
  557.     ;; Writable.
  558.     (and (file-writable-p path)
  559.      ;; We can never delete the last article in the group.
  560.      (not (eq (cdr (nth 1 (assoc group nnmh-group-alist)))
  561.           article)))))
  562.  
  563. (provide 'nnmh)
  564.  
  565. ;;; nnmh.el ends here
  566.